Developmental differences in sensitivity to high variance feedback

This notebook contains exploratory analyses of behavioral data collected to investigate the relationship between risk taking behavior and probabilistic learning.

The sample consists of three age groups: kids, teens and adults and we hypothesize that sensitivity to learn from high variance feedback improves with age (and this is related to better risky decisions).

Subjects completed a probabilistic learning task in the scanner, a risky decision making task (BART) outside the scanner and numerous questionnaires. The focus of this notebook is on the first task.

The plan of analysis is to establish that adults are more sensitive to high variance feedback in the probabilistic learning task and relate this (modeled) sensitivity to behavior in BART.

Sample info

First let’s get a sense of the sample. Here is how many subjects we have who have complete datasets for the probabilistic learning task and their age break downs.

machine_game_data_clean %>% 
  group_by(age_group) %>%
  summarise(min_age = min(calc_age),
            mean_age = mean(calc_age),
            sd_age = sd(calc_age),
            max_age = max(calc_age),
            n = n()/180)

Performance in RL task

In this task subjects are presented with a fractal in each trial. The fractals represent different machines (single-armed bandits). Subjects choose to play or pass in each trial. Each machine yields a probabilistic reward. There are four machines in total. Two with positive and two with negative expected value. One of each of these machines has a low variance reward schedule while the other has a high variance reward schedule.

• One machine gives $5 90% of the time and -$495 %10 of the time
  
• One machine gives -$5 90% of the time and $495 %10 of the time
  
• One machine gives $10 50% of the time and -$100 %50 of the time
  
• One machine gives -$10 50% of the time and $100 %50 of the time

Points earned

Performance in this task can be assessed by looking at the total number of points subjects make at the end of task. The following graph shows that adults collect more points in this task compared to kids.

machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  summarise(total_points = sum(Points_earned)) %>%
  do(assign.age.info(.)) %>%
  group_by(age_group) %>%
  summarise(mean_points = mean(total_points),
            sem_points = sem(total_points)) %>%
  ggplot(aes(age_group, mean_points))+
  geom_bar(stat='identity', position = position_dodge((0.9)))+
  geom_errorbar(aes(ymin=mean_points-sem_points, ymax=mean_points+sem_points), position = position_dodge(0.9), width=0.25)+
  theme_bw()+
  xlab('Machine')+
  ylab('Mean points')+
  labs(fill='Age group')

This difference is statistically significant: adults earn more points compared to the kids.

tmp = machine_game_data_clean %>%
  group_by(Sub_id) %>%
  summarise(total_points = sum(Points_earned)) %>%
  do(assign.age.info(.))

summary(lm(total_points~age_group, data=tmp))

Call:
lm(formula = total_points ~ age_group, data = tmp)

Residuals:
    Min      1Q  Median      3Q     Max 
-2820.0  -957.6  -203.5  1131.9  2416.5 

Coefficients:
               Estimate Std. Error t value Pr(>|t|)   
(Intercept)       277.6      248.1   1.119   0.2670   
age_groupteen     525.9      408.2   1.289   0.2017   
age_groupadult    972.4      350.9   2.771   0.0071 **
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 1336 on 72 degrees of freedom
Multiple R-squared:  0.09651,   Adjusted R-squared:  0.07141 
F-statistic: 3.845 on 2 and 72 DF,  p-value: 0.0259

Since we are interested in the age differences between sensitivity to different feedback schedules, we should show that this difference in performance exists especially for the high variance feedback condition(s). Here is the plot of performance (total points earned) broken down by conditions.

machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  summarise(total_points = sum(Points_earned)) %>%
  do(assign.age.info(.)) %>%
  group_by(age_group, facet_labels) %>%
  summarise(mean_points = mean(total_points),
            sem_points = sem(total_points)) %>%
  ggplot(aes(facet_labels, mean_points, fill=age_group))+
  geom_bar(stat='identity', position = position_dodge((0.9)))+
  geom_errorbar(aes(ymin=mean_points-sem_points, ymax=mean_points+sem_points), position = position_dodge(0.9), width=0.25)+
  # theme_bw()+
  xlab('Machine')+
  ylab('Mean points')+
  labs(fill='Age group')

ggsave("Points_earned.jpeg", device = "jpeg", path = fig_path, width = 7, height = 5, units = "in", dpi = 450)

Running separate models for positive and negative EV machines for ease of interpretation.

tmp <- machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  summarise(total_points = sum(Points_earned)) %>%
  do(assign.age.info(.))

In the positive EV machines there is a main effect for the high variance machine. Subjects earn fewer points in the high variance condition compared to the low variance condition. There are no age differences.

summary(lm(total_points ~ age_group*facet_labels, data = tmp %>% filter(facet_labels %in% c("-10,+100", "-5,+495"))))

Call:
lm(formula = total_points ~ age_group * facet_labels, data = tmp %>% 
    filter(facet_labels %in% c("-10,+100", "-5,+495")))

Residuals:
     Min       1Q   Median       3Q      Max 
-1305.17  -354.12    64.83   432.46   989.83 

Coefficients:
                                   Estimate Std. Error t value Pr(>|t|)
(Intercept)                         1475.17      88.98  16.580   <2e-16
age_groupteen                        208.95     146.36   1.428   0.1556
age_groupadult                       215.86     125.83   1.716   0.0884
facet_labels-5,+495                 -293.62     125.83  -2.333   0.0210
age_groupteen:facet_labels-5,+495    -40.50     206.99  -0.196   0.8452
age_groupadult:facet_labels-5,+495  -112.24     177.95  -0.631   0.5292
                                      
(Intercept)                        ***
age_groupteen                         
age_groupadult                     .  
facet_labels-5,+495                *  
age_groupteen:facet_labels-5,+495     
age_groupadult:facet_labels-5,+495    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 479.1 on 144 degrees of freedom
Multiple R-squared:  0.1457,    Adjusted R-squared:  0.116 
F-statistic: 4.912 on 5 and 144 DF,  p-value: 0.0003511

In the negative EV machines there is again a main effect for the high variance machine: Everyone losses fewer points in the low variance condition. There is also a main effect for adults: Adults perform better than kids for both negative EV machines.

summary(lm(total_points ~ age_group*facet_labels, data = tmp %>% filter(facet_labels %in% c("+10,-100", "+5,-495"))))

Call:
lm(formula = total_points ~ age_group * facet_labels, data = tmp %>% 
    filter(facet_labels %in% c("+10,-100", "+5,-495")))

Residuals:
     Min       1Q   Median       3Q      Max 
-1236.21  -388.79    33.79   387.24  1000.34 

Coefficients:
                                   Estimate Std. Error t value Pr(>|t|)
(Intercept)                         -953.79      89.33 -10.677  < 2e-16
age_groupteen                         59.68     146.95   0.406 0.685276
age_groupadult                       296.55     126.34   2.347 0.020271
facet_labels+5,-495                 -471.55     126.34  -3.733 0.000272
age_groupteen:facet_labels+5,-495     29.20     207.82   0.141 0.888460
age_groupadult:facet_labels+5,-495    59.83     178.67   0.335 0.738222
                                      
(Intercept)                        ***
age_groupteen                         
age_groupadult                     *  
facet_labels+5,-495                ***
age_groupteen:facet_labels+5,-495     
age_groupadult:facet_labels+5,-495    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 481.1 on 144 degrees of freedom
Multiple R-squared:  0.2421,    Adjusted R-squared:  0.2158 
F-statistic: 9.199 on 5 and 144 DF,  p-value: 1.289e-07

So the age diffence in performance is driven by difference in performance in negative EV machines. The question is what difference in behavior in these conditions is leading to this difference in performance?

To anticipate possible cognitive processes that will be parameterized in RL models differences can lie in: how quickly the groups learn the probabilities, how much weight they put on the outcomes and/or how much like an optimal agent they behave.

Proportion of playing

The first thing we can look at is how often subjects play versus pass. It’s hard to see any age differences when we just look at frequency of overall playing as below.

machine_game_data_clean %>%
  group_by(Sub_id, Response) %>%
  tally %>%
  group_by(Sub_id) %>%
  mutate(pct=(100*n)/sum(n)) %>%
  do(assign.age.info(.)) %>%
  group_by(age_group, Response) %>%
  dplyr::summarise(mean_pct = mean(pct),
            sem_pct = sem(pct)) %>%
  ggplot(aes(Response, mean_pct, fill = age_group))+
  geom_bar(stat='identity', position = position_dodge(0.9))+
  geom_errorbar(aes(ymin = mean_pct - sem_pct, ymax = mean_pct + sem_pct), position = position_dodge(width = 0.9), width=0.25)+
  theme_bw()+
  ylab('Percentage of trials')+
  labs(fill = 'Age group')

It is also not immediately apparent how to translate this to better performance/learning in this task but one way to think about it: If people learned perfectly they should play half of the time (always for the positive expected value trial and never for the negative expected value trials). The fact that all play proportions are above 50% suggests that nobody learns perfectly and that adults might be closest to it. But this is very crude and a better way to look at it would be to see

1. how this depends on the different machines and
   
2. how it changes throughout the task.

To get a better sense of overall behavior in different contingency states we break this proportion of playing down by machines.

Now we can see age differences in playing frequency in different conditions, particularly in the negative expected value machines (bottom row).

machine_game_data_clean %>%
  group_by(Sub_id, facet_labels, Response) %>%
  tally %>%
  group_by(Sub_id, facet_labels) %>%
  mutate(pct=(100*n)/sum(n)) %>%
  do(assign.age.info(.)) %>%
  group_by(age_group, facet_labels, Response) %>%
  dplyr::summarise(mean_pct = mean(pct),
            sem_pct = sem(pct)) %>%
  ggplot(aes(Response, mean_pct, fill = age_group))+
  geom_bar(stat='identity', position = position_dodge(0.9))+
  geom_errorbar(aes(ymin = mean_pct - sem_pct, ymax = mean_pct + sem_pct), position = position_dodge(width = 0.9), width=0.25)+
  theme_bw()+
  ylab('Percentage of trials')+
  facet_wrap(~facet_labels)+
  labs(fill = 'Age group')

The differences in points earned map directly on to proportion of choosing to play each machine:

• Adults play less than kids for both negative EV machines.
• Everyone plays the high var positive EV machine less than the low var positive EV machine.
• Everyone plays the low var negative EV machines less than the low var positive EV machine.

tmp <- machine_game_data_clean %>%
  group_by(Sub_id, facet_labels, Response) %>%
  tally %>%
  group_by(Sub_id, facet_labels) %>%
  mutate(pct_play=(100*n)/sum(n)) %>%
  filter(Response == 'play') %>%
  do(assign.age.info(.))

summary(lmer(pct_play ~ age_group*facet_labels + (1|Sub_id), data = tmp))

Linear mixed model fit by REML ['lmerMod']
Formula: pct_play ~ age_group * facet_labels + (1 | Sub_id)
   Data: tmp

REML criterion at convergence: 2642.6

Scaled residuals: 
     Min       1Q   Median       3Q      Max 
-2.65914 -0.69208  0.03646  0.75004  1.97139 

Random effects:
 Groups   Name        Variance Std.Dev.
 Sub_id   (Intercept)  50.81    7.128  
 Residual             451.18   21.241  
Number of obs: 300, groups:  Sub_id, 75

Fixed effects:
                                    Estimate Std. Error t value
(Intercept)                          74.2529     4.1605  17.847
age_groupteen                        10.1916     6.8439   1.489
age_groupadult                        9.6103     5.8839   1.633
facet_labels-5,+495                 -17.0115     5.5782  -3.050
facet_labels+10,-100                -28.2759     5.5782  -5.069
facet_labels+5,-495                 -10.4215     5.5782  -1.868
age_groupteen:facet_labels-5,+495    -0.7663     9.1758  -0.084
age_groupadult:facet_labels-5,+495   -1.7751     7.8887  -0.225
age_groupteen:facet_labels+10,-100  -13.2928     9.1758  -1.449
age_groupadult:facet_labels+10,-100 -23.7866     7.8887  -3.015
age_groupteen:facet_labels+5,-495   -14.4151     9.1758  -1.571
age_groupadult:facet_labels+5,-495  -27.7457     7.8887  -3.517

Correlation of Fixed Effects:
                  (Intr) ag_grpt ag_grpd f_-5,+ f_+10, f_+5,-
age_grouptn       -0.608                                     
age_gropdlt       -0.707  0.430                              
fct_-5,+495       -0.670  0.408   0.474                      
fc_+10,-100       -0.670  0.408   0.474   0.500              
fct_+5,-495       -0.670  0.408   0.474   0.500  0.500       
ag_grpt:_-5,+495   0.408 -0.670  -0.288  -0.608 -0.304 -0.304
ag_grpd:_-5,+495   0.474 -0.288  -0.670  -0.707 -0.354 -0.354
ag_grpt:_+10,-100  0.408 -0.670  -0.288  -0.304 -0.608 -0.304
ag_grpd:_+10,-100  0.474 -0.288  -0.670  -0.354 -0.707 -0.354
ag_grpt:_+5,-495   0.408 -0.670  -0.288  -0.304 -0.304 -0.608
ag_grpd:_+5,-495   0.474 -0.288  -0.670  -0.354 -0.354 -0.707
                  ag_grpt:_-5,+495 ag_grpd:_-5,+495 ag_grpt:_+10,-100
age_grouptn                                                          
age_gropdlt                                                          
fct_-5,+495                                                          
fc_+10,-100                                                          
fct_+5,-495                                                          
ag_grpt:_-5,+495                                                     
ag_grpd:_-5,+495   0.430                                             
ag_grpt:_+10,-100  0.500            0.215                            
ag_grpd:_+10,-100  0.215            0.500            0.430           
ag_grpt:_+5,-495   0.500            0.215            0.500           
ag_grpd:_+5,-495   0.215            0.500            0.215           
                  ag_grpd:_+10,-100 ag_grpt:_+5,-495
age_grouptn                                         
age_gropdlt                                         
fct_-5,+495                                         
fc_+10,-100                                         
fct_+5,-495                                         
ag_grpt:_-5,+495                                    
ag_grpd:_-5,+495                                    
ag_grpt:_+10,-100                                   
ag_grpd:_+10,-100                                   
ag_grpt:_+5,-495   0.215                            
ag_grpd:_+5,-495   0.500             0.430          

This is not surprising given what the number of points earned already showed. But now that we are looking at a behavioral measure instead of an outcome measure we might be able to quantify constructs of interest like sensitivity to variance or sensitivity to the expected values of the machines.

As a first step to translate raw playing behavior to learning I recoded the choices to be correct when a subject chooses to play a positive expected value machine and pass a negative expected value machine and incorrect when the reverse is true. If a subject is learning they should be learning to play the positive expected machines and to pass the others.

Learning

Recoding the behavior in this way gave a clearer picture of the age difference in learning of optimal behavior between the conditions. Specifically we can now look at how the probability of a correct choice changes for each age group in each condition across trials.

machine_game_data_clean %>%
  ggplot(aes(scale(Trial_number), correct1_incorrect0))+
  geom_line(aes(group = Sub_id, col= factor(age_group, levels=c('kid', 'teen', 'adult'))),stat='smooth', method = 'glm', method.args = list(family = "binomial"), se = FALSE, alpha=0.2)+
  geom_line(aes(col= factor(age_group, levels=c('kid', 'teen', 'adult'))),stat='smooth', method = 'glm', method.args = list(family = "binomial"), se = FALSE, alpha=1, size=2)+
  facet_wrap(~facet_labels)+
  theme_bw()+
  xlab("Relative trial number")+
  scale_y_continuous(breaks=c(0,1))+
  labs(col="Age group")+
  ylab('Correct choice')+
  theme(legend.position = "bottom",
        panel.grid = element_blank())

ggsave("Learning.jpeg", device = "jpeg", path = fig_path, width = 8, height = 5, units = "in", dpi = 450)

Looking at learning effects separately for each machine to avoid interpreting messy three-way interactions.

Adults are more likely to make correct decisions in low var positive EV machine.

summary(glmer(correct1_incorrect0 ~ age_group*scale(Trial_number)+(1|Sub_id), data = machine_game_data_clean %>% filter(facet_labels %in% c('-10,+100')), family=binomial))

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct1_incorrect0 ~ age_group * scale(Trial_number) + (1 |  
    Sub_id)
   Data: 
machine_game_data_clean %>% filter(facet_labels %in% c("-10,+100"))

     AIC      BIC   logLik deviance df.resid 
  2802.7   2845.5  -1394.3   2788.7     3364 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-6.1092  0.1244  0.2237  0.4674  1.8848 

Random effects:
 Groups Name        Variance Std.Dev.
 Sub_id (Intercept) 2.437    1.561   
Number of obs: 3371, groups:  Sub_id, 75

Fixed effects:
                                    Estimate Std. Error z value Pr(>|z|)
(Intercept)                         1.436722   0.303684   4.731 2.23e-06
age_groupteen                       0.864371   0.508376   1.700   0.0891
age_groupadult                      1.091426   0.440513   2.478   0.0132
scale(Trial_number)                 0.007478   0.068963   0.108   0.9136
age_groupteen:scale(Trial_number)  -0.015514   0.126248  -0.123   0.9022
age_groupadult:scale(Trial_number)  0.103024   0.111180   0.927   0.3541
                                      
(Intercept)                        ***
age_groupteen                      .  
age_groupadult                     *  
scale(Trial_number)                   
age_groupteen:scale(Trial_number)     
age_groupadult:scale(Trial_number)    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
             (Intr) ag_grpt ag_grpd sc(T_) ag_grpt:(T_)
age_grouptn  -0.591                                    
age_gropdlt  -0.679  0.413                             
scl(Trl_nm)   0.001  0.000   0.000                     
ag_grpt:(T_)  0.000 -0.001   0.000  -0.546             
ag_grpd:(T_)  0.000  0.001   0.012  -0.620  0.339      

The probability of making a correct response for the high var positive EV machine doesn’t change for adults or kids but increases for teens across trials.

summary(glmer(correct1_incorrect0 ~ age_group*scale(Trial_number)+(1|Sub_id), data = machine_game_data_clean %>% filter(facet_labels %in% c('-5,+495')), family=binomial))

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct1_incorrect0 ~ age_group * scale(Trial_number) + (1 |  
    Sub_id)
   Data: 
machine_game_data_clean %>% filter(facet_labels %in% c("-5,+495"))

     AIC      BIC   logLik deviance df.resid 
  3596.7   3639.5  -1791.3   3582.7     3363 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-4.5183 -0.7139  0.2926  0.5768  3.5857 

Random effects:
 Groups Name        Variance Std.Dev.
 Sub_id (Intercept) 2.196    1.482   
Number of obs: 3370, groups:  Sub_id, 75

Fixed effects:
                                   Estimate Std. Error z value Pr(>|z|)  
(Intercept)                         0.42598    0.28422   1.499   0.1339  
age_groupteen                       0.53501    0.46878   1.141   0.2538  
age_groupadult                      0.53030    0.40470   1.310   0.1901  
scale(Trial_number)                 0.02285    0.06369   0.359   0.7198  
age_groupteen:scale(Trial_number)   0.25742    0.10980   2.345   0.0191 *
age_groupadult:scale(Trial_number)  0.01845    0.09517   0.194   0.8463  
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
             (Intr) ag_grpt ag_grpd sc(T_) ag_grpt:(T_)
age_grouptn  -0.606                                    
age_gropdlt  -0.702  0.426                             
scl(Trl_nm)   0.000  0.000   0.000                     
ag_grpt:(T_)  0.000  0.013   0.001  -0.580             
ag_grpd:(T_)  0.000  0.000   0.002  -0.669  0.388      

All groups show improvement across trials for the low var negative EV machine but adults learn faster than kids and teens.

summary(glmer(correct1_incorrect0 ~ age_group*scale(Trial_number)+(1|Sub_id), data = machine_game_data_clean %>% filter(facet_labels %in% c('+10,-100')), family=binomial))

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct1_incorrect0 ~ age_group * scale(Trial_number) + (1 |  
    Sub_id)
   Data: 
machine_game_data_clean %>% filter(facet_labels %in% c("+10,-100"))

     AIC      BIC   logLik deviance df.resid 
  4004.9   4047.8  -1995.5   3990.9     3368 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-4.1747 -0.8618  0.3667  0.7401  3.7838 

Random effects:
 Groups Name        Variance Std.Dev.
 Sub_id (Intercept) 1.048    1.024   
Number of obs: 3375, groups:  Sub_id, 75

Fixed effects:
                                   Estimate Std. Error z value Pr(>|z|)
(Intercept)                        -0.13227    0.20125  -0.657 0.511016
age_groupteen                       0.47378    0.33003   1.436 0.151123
age_groupadult                      1.00065    0.28556   3.504 0.000458
scale(Trial_number)                 0.30159    0.06298   4.789 1.68e-06
age_groupteen:scale(Trial_number)  -0.01943    0.10144  -0.192 0.848077
age_groupadult:scale(Trial_number)  0.33528    0.09316   3.599 0.000319
                                      
(Intercept)                           
age_groupteen                         
age_groupadult                     ***
scale(Trial_number)                ***
age_groupteen:scale(Trial_number)     
age_groupadult:scale(Trial_number) ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
             (Intr) ag_grpt ag_grpd sc(T_) ag_grpt:(T_)
age_grouptn  -0.610                                    
age_gropdlt  -0.706  0.431                             
scl(Trl_nm)  -0.003  0.002   0.003                     
ag_grpt:(T_)  0.001  0.005  -0.001  -0.620             
ag_grpd:(T_)  0.000  0.000   0.032  -0.674  0.419      

Kids don’t show learning across trials for the high var negative EV machine but adults and teens do.

summary(glmer(correct1_incorrect0 ~ age_group*scale(Trial_number)+(1|Sub_id), data = machine_game_data_clean%>% filter(facet_labels %in% c('+5,-495')), family=binomial))

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct1_incorrect0 ~ age_group * scale(Trial_number) + (1 |  
    Sub_id)
   Data: 
machine_game_data_clean %>% filter(facet_labels %in% c("+5,-495"))

     AIC      BIC   logLik deviance df.resid 
  3873.0   3915.9  -1929.5   3859.0     3377 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-2.5639 -0.6775 -0.3712  0.7531  3.1844 

Random effects:
 Groups Name        Variance Std.Dev.
 Sub_id (Intercept) 1.207    1.099   
Number of obs: 3384, groups:  Sub_id, 75

Fixed effects:
                                   Estimate Std. Error z value Pr(>|z|)
(Intercept)                        -0.92874    0.21603  -4.299 1.71e-05
age_groupteen                       0.38389    0.35357   1.086 0.277582
age_groupadult                      1.06277    0.30440   3.491 0.000481
scale(Trial_number)                 0.02308    0.06472   0.357 0.721394
age_groupteen:scale(Trial_number)   0.39678    0.10592   3.746 0.000180
age_groupadult:scale(Trial_number)  0.70453    0.09512   7.407 1.29e-13
                                      
(Intercept)                        ***
age_groupteen                         
age_groupadult                     ***
scale(Trial_number)                   
age_groupteen:scale(Trial_number)  ***
age_groupadult:scale(Trial_number) ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
             (Intr) ag_grpt ag_grpd sc(T_) ag_grpt:(T_)
age_grouptn  -0.611                                    
age_gropdlt  -0.710  0.433                             
scl(Trl_nm)  -0.001  0.001   0.001                     
ag_grpt:(T_)  0.000 -0.014   0.000  -0.611             
ag_grpd:(T_) -0.002  0.001   0.010  -0.680  0.417      

I tried to capture these effects in ‘individual difference’ variables by running the logistic regression separately for each subject in each condition. This wouldn’t capture anything different than the above analyses but I wanted to see if there were any subject-specific indices that could be correlated with other measues. I looked at three parameters:

• The intercept: whether they are more or less likely to choose the optimal action having seen half of the trials (p>0.5 if intercept>0 (i.e. log(0.5/0.5)))
• The slope: which direction and how fast the sigmoid moves in (for learning this must be positive and the larger it is the better the learning)
  
• The learning index: where in the task (i.e. scaled trial number) they are at 50% for each machine (switch point - I came up with this to capture change in both parameters. I’m not sure if it makes sense.) The smaller the better (the sooner they learn the better choice).

Because each model is run only on 45 trials the fits aren’t great and the parameter distributions have large variances.

get_learning_coef <- function(data){
  model = glm(correct1_incorrect0 ~ scale(Trial_number), family = binomial(link=logit), data = data)
  b0 = coef(model)[1]
  b1 = coef(model)[2]
  learnIndex = -b0/b1                   
  return(data.frame(b0, b1, learnIndex))
}


tmp = machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  do(get_learning_coef(.)) %>%
  do(assign.age.info(.)) 

(Error bars not shown because they are very large due to bad fits).
As expected the difference between kids and adults in slopes for the high variance negative EV machine is visible here too.

tmp %>%
  ungroup()%>%
  select(facet_labels, age_group, b0, b1, learnIndex) %>%
  gather(key, value, -facet_labels, -age_group) %>%
  group_by(age_group, facet_labels, key) %>%
  summarise(mv = median(value),
            sv = sem(value)) %>%
  ggplot(aes(facet_labels, mv, fill=age_group))+
  geom_bar(stat="identity", position = position_dodge())+
  # geom_errorbar(aes(ymin = mv-sv, ymax = mv+sv), position = position_dodge(width = 0.9), width=0)+
  facet_wrap(~key, scale="free")+
  theme(legend.position = "bottom",
        legend.title = element_blank())+
  xlab("")+
  ylab("Median value")

But it’s not a good idea to look for group differences in these parameters as they are highly variable due to bad fits from few trials.

Correlation with BART

Quick look at how this relates to BART data:

adjusted.pumps <- function(subject_data){
  subject_data_adjusted = subject_data[subject_data$exploded == 0,]
  subject_pumps <- subject_data_adjusted %>% 
    group_by(trial.num) %>%
    summarise(total_pumps = sum(finished))
  out <- data.frame(mean_adjusted_pumps = mean(subject_pumps$total_pumps))
  return(out)
}

Increase in number of pumps with age

bart_data %>%
  group_by(Sub_id) %>%
  do(adjusted.pumps(.)) %>%
  do(assign.age.info(.)) %>%
  ggplot(aes(x=calc_age, y = mean_adjusted_pumps))+
  geom_point()+
  theme_bw()+
  geom_smooth(method = "lm") +
  xlab("Age")+
  ylab("Risk taking (adjusted pumps)")

There aren’t any meaningful correlations between slopes and mean adjusted pumps. BUT neither of these seem like good individual difference measures.

tmp = bart_data %>%
  group_by(Sub_id) %>%
  do(adjusted.pumps(.)) %>%
  do(assign.age.info(.)) %>%
  select(Sub_id, mean_adjusted_pumps)

machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  do(get_learning_coef(.)) %>%
  do(assign.age.info(.)) %>%
  left_join(tmp, by = 'Sub_id') %>%
  group_by(facet_labels, age_group) %>%
  summarise(cor = cor.test(b1, mean_adjusted_pumps)$estimate,
            p_value = cor.test(b1, mean_adjusted_pumps)$p.value) %>%
  arrange(cor)

Variance vs. EV sensitivity

Does it makes sense to look at these separately?

Since the machines differ in the variance of the outcomes and expected values it might seem sensible to look at which of these attributes has a larger effect on performance.

It’s tempting to tease apart the relative importance of these attributes for the high variance negative EV machine where we observe the performance difference between age groups.

BUT these attributes are correlated. So we can’t look at their effects separately in the same model.

#Function to calculate observed variance and observed expected value based on outcomes in trials that the subject has played.
get_obs_var_ev <- function(data){
  
  new_data = data
  new_data$obs_var <- NA
  new_data$obs_ev <-  NA
  
  for(i in 1:nrow(new_data)){
    if(i == 1){
      obs = 0
      obs_ev = 0
      obs_var = 0
    }
    else{
      #get all the trials until the current trial
      obs = new_data[1:i,]
      #filter only played trials; their belief should not be updated based on the trials they haven't played
      obs = obs %>% filter(Response == "play") %>% ungroup() %>% select(Points_earned)
      obs_var = var(obs)
      obs_probs =  as.numeric(prop.table(table(obs)))
      obs_rewards = as.numeric(names(prop.table(table(obs))))
      obs_ev = sum(obs_probs*obs_rewards)
    }
    new_data$obs_var[i] = obs_var
    new_data$obs_ev[i] = obs_ev
  }
  new_data$obs_var = ifelse(is.na(new_data$obs_var), 0, new_data$obs_var)
  return(new_data)
}

tmp = machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  do(get_obs_var_ev(.))

tmp %>%
  ggplot(aes(obs_var, obs_ev))+
  geom_point()+
  facet_wrap(~facet_labels, scales="free")+
  xlab("Observed variance")+
  ylab("Observed EV")

What we are interested in is the effect of beliefs about the machines on behavior. These beliefs can be summarized quantitatively in an ‘expected value.’

The cognitive processes that can differ with respect to this expected value can be how quickly it approaches the true expected value of a machine (the rate at which one incorporates each new data point to existing beliefs) and how truthfully the expected values are evaluated (is the utility of the expected value the same as its value).

These two processes can be captured as the learning rate and the exponent on the prediction error in an RL model.

Before moving on to modeling results here I plot the effect of observed EV (not model based) on choice to confirm that it makes sense and captures the behavioral effect:
The higher the EV of a machine the more likely it is to be played. This is the correct action for the positive EV machines but incorrect action for the negative EV machines. The behavioral effect in the high var negative EV machine is captured again with the diverging lines for age groups at low EVs.

tmp %>%
  ggplot(aes(obs_ev, correct1_incorrect0))+
  geom_line(aes(group = Sub_id, col= age_group),stat='smooth', method = 'glm', method.args = list(family = "binomial"), se = FALSE, alpha=0.2)+
  geom_line(aes(col= age_group),stat='smooth', method = 'glm', method.args = list(family = "binomial"), se = FALSE, alpha=1, size=2)+
  facet_wrap(~facet_labels, scales='free')+
  xlab("EV of played trials")+
  scale_y_continuous(breaks=c(0,1))+
  labs(col="Age group")+
  ylab('Correct')+
  theme(legend.position = "bottom",
        legend.title = element_blank())

Additional behavioral patterns

Though I focus on learning behavior and specifically difference in learning for the high variance negative EV machine there are other possible behavioral patterns that might also differ between the age groups. Here I list some examples.

Initial exploration

Do people ‘explore’ the first five trials where the reward probabilities for each machine are presented?

They explore less when they encounter a loss early on. In the high var pos EV machine they get 4 (small) losses in a row; in the low var negative EV machine they get a moderate loss in the first trial.

machine_game_data_clean %>% 
  group_by(Sub_id, facet_labels) %>%
  slice(1:5) %>%
  summarise(num_explored = sum(ifelse(Response == "play", 1,0))) %>%
  do(assign.age.info(.)) %>%
  ungroup() %>%
  group_by(age_group, facet_labels) %>%
  summarise(mean_num_explored = mean(num_explored/5*100),
            sem_num_explored = sem(num_explored/5*100)) %>%
  ggplot(aes(facet_labels, mean_num_explored, fill = age_group))+
  geom_bar(stat="identity",position = position_dodge(0.9))+
  geom_errorbar(aes(ymax = mean_num_explored+sem_num_explored, ymin = mean_num_explored-sem_num_explored), position = position_dodge(width = 0.9), width=0.25)+
  theme(legend.title = element_blank())+
  ylab("Percentage of exploration")+
  xlab("")

Memory effect

How does performance change depending on the delay between the last time a machine was played?

Can we think of this as a ‘memory effect’? The more trials since the last time you have played a machine, the more forgetting/interference?

For positive EV machines this is true for all groups. This is evident in the decreasing probability of a correct response the longer it has been since the last time a machine was played.

For negative EV machines adults and teens continue to make correct choices even if a lot of trials have passed since they last played that machine. Kids don’t seem to remember that the machine is ‘bad’ and are more likely to make an incorrect choice (and play the machine) the longer it’s been since they last played it.

machine_game_data_clean %>%
  group_by(Sub_id) %>%
  mutate(played_trial_number = ifelse(Response == "play", Trial_number, NA)) %>%
  mutate(played_trial_number = na.locf(played_trial_number, na.rm=F)) %>%
  filter(Trial_number > 1) %>%
  mutate(trials_since_last_played = Trial_number - lag(played_trial_number)) %>%
  group_by(trials_since_last_played,facet_labels, age_group) %>%
  summarise(mean_correct = mean(correct1_incorrect0, na.rm = T),
            sem_correct = sem(correct1_incorrect0)) %>%
  drop_na() %>%
  ggplot(aes(trials_since_last_played, mean_correct, col = age_group))+
  # geom_smooth(alpha=0.5, method='lm')+
  # geom_point()+
  geom_line(stat='smooth', method = 'glm', method.args = list(family = "binomial"), alpha=1, size=2)+
  facet_wrap(~facet_labels)+
  theme(legend.title = element_blank())+
  xlab("Trials since last played")+
  ylab("Mean Correct")

Post-loss behavior

If subjects are sensitive to losses and learning something about the machines in a way that overweights their most recent experience with the machine one sanity check is to compare how many trials it takes subjects to play a machine again after a loss versus a gain. Presumably the former would be higher than the latter. One might hesitate to play a machine again after a loss but be more likely to play it after a gain.

count.postoutcome.trials <- function(subject_data){
  
  loss_trials = which(subject_data$Points_earned<0)
  
  gain_trials = which(subject_data$Points_earned>0)
  
  play_trials= which(subject_data$Response == "play")
  
  post_loss_trials = play_trials[which(play_trials %in% loss_trials)+1]
  
  post_gain_trials = play_trials[which(play_trials %in% gain_trials)+1]
  
  num_trials_post_loss = post_loss_trials - loss_trials
  
  num_trials_post_gain = post_gain_trials - gain_trials
  
  if(length(num_trials_post_gain)>length(num_trials_post_loss)){
    num_trials_post_loss <- c(num_trials_post_loss, rep(NA, length(num_trials_post_gain) - length(num_trials_post_loss)))
  }
  else if(length(num_trials_post_gain)<length(num_trials_post_loss)){
    num_trials_post_gain <- c(num_trials_post_gain, rep(NA, length(num_trials_post_loss) - length(num_trials_post_gain)))
  }
  
  return(data.frame(num_trials_post_loss = num_trials_post_loss, num_trials_post_gain = num_trials_post_gain))
}

The plot below shows the average number of trials it takes a subject to play a given machine after experiencing a loss or a gain.

For everyone and for every machine the average number of trials it takes a subject to play following a loss is higher than the average number of trials it take them to play following a gain. This suggests that subjects are responding to outcomes in a way overweights their most recent experience with the machine.

tmp = machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  do(count.postoutcome.trials(.))  %>%
  do(assign.age.info(.)) %>%
  ungroup() %>%
  select(facet_labels, age_group, num_trials_post_loss, num_trials_post_gain, Sub_id) %>%
  gather(key, value, -facet_labels, -age_group, -Sub_id) %>%
  mutate(key = gsub("num_trials_post_", "", key)) 

tmp %>%
  group_by(facet_labels, age_group, key) %>%
  summarise(mean_post = mean(value, na.rm=T),
            sem_post = sem(value)) %>%
  ggplot(aes(age_group, mean_post, shape=key, col=age_group))+
  geom_point(size=2)+
  geom_errorbar(aes(ymin = mean_post-sem_post, ymax = mean_post+sem_post), width=0, size=2)+
  facet_wrap(~facet_labels)+
  xlab("Number of trials until next play")+
  theme(legend.title = element_blank())+
  guides(color=FALSE)

Reflecting the global behavior in proportion of playing in each condition adults take longer to play after large losses in the high variance negative EV condition compared to kids while kids are less sensitive to the magnitude of loss.

summary(lm(value~age_group*facet_labels,tmp %>%filter(key=="loss")))

Call:
lm(formula = value ~ age_group * facet_labels, data = tmp %>% 
    filter(key == "loss"))

Residuals:
    Min      1Q  Median      3Q     Max 
-1.8711 -0.4617 -0.4138 -0.2342 26.8007 

Coefficients:
                                    Estimate Std. Error t value Pr(>|t|)
(Intercept)                          1.41929    0.07378  19.236  < 2e-16
age_groupteen                       -0.18511    0.11688  -1.584 0.113334
age_groupadult                      -0.15072    0.10193  -1.479 0.139327
facet_labels-5,+495                  0.25664    0.09722   2.640 0.008327
facet_labels+10,-100                 0.78004    0.11923   6.542 6.84e-11
facet_labels+5,-495                  0.56908    0.18878   3.015 0.002590
age_groupteen:facet_labels-5,+495   -0.02910    0.15335  -0.190 0.849487
age_groupadult:facet_labels-5,+495  -0.11137    0.13387  -0.832 0.405494
age_groupteen:facet_labels+10,-100   0.35057    0.19689   1.781 0.075069
age_groupadult:facet_labels+10,-100  0.82253    0.18041   4.559 5.29e-06
age_groupteen:facet_labels+5,-495    0.40507    0.31298   1.294 0.195654
age_groupadult:facet_labels+5,-495   1.00609    0.28488   3.532 0.000418
                                       
(Intercept)                         ***
age_groupteen                          
age_groupadult                         
facet_labels-5,+495                 ** 
facet_labels+10,-100                ***
facet_labels+5,-495                 ** 
age_groupteen:facet_labels-5,+495      
age_groupadult:facet_labels-5,+495     
age_groupteen:facet_labels+10,-100  .  
age_groupadult:facet_labels+10,-100 ***
age_groupteen:facet_labels+5,-495      
age_groupadult:facet_labels+5,-495  ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 1.611 on 3982 degrees of freedom
  (1675 observations deleted due to missingness)
Multiple R-squared:  0.07091,   Adjusted R-squared:  0.06834 
F-statistic: 27.63 on 11 and 3982 DF,  p-value: < 2.2e-16

One thought that is not necessarily immediately pertinent but that I puzzled over is how this graph would have looked like if subjects were taking all their experiences with the machine in to account (instead of overweighing their most recent experience). I have a vague intuition that in that case the difference in responding between the experiences (gain/loss) would be 0. That is, if one takes in to account all their experiences then they would distinguish between the positive and negative EV machines and either always play for positive EV machines or never play for negative EV machines regardless of the observed outcome. Relatedly then, this difference in response patterns depending on the observed outcome could be due to at least two reasons: memory or loss aversion. Or perhaps stronger memories for losses. I’m not sure where I’m going with this but perhaps there is something interesting to look at in the hippocampal activity following losses versus gains.

Cross-talk between machines

Are subjects less likely to play overall after a loss or only less likely to play that machine after a loss for that machine?

mean.postloss.play.prob <- function(subject_data){
  
  Sub_id = unique(subject_data$Sub_id)
  
  loss_trials = which(subject_data$Points_earned<0)
  
  mean_post_loss_prob <- mean(ifelse(subject_data$Response[loss_trials+1] == "play", 1, 0), na.rm=T)
  
  return(data.frame(mean_post_loss_prob=mean_post_loss_prob))
}

Probability of playing following a loss depends on machine type. Looking at all trials masks this difference. Subjects seem to learn machine specifically and cross-talk isn’t evident here.

tmp = machine_game_data_clean %>%
  group_by(Sub_id) %>%
  do(mean.postloss.play.prob(.)) %>%
  mutate(facet_labels = "all_trials")

machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  do(mean.postloss.play.prob(.)) %>%
  rbind(tmp) %>%
  do(assign.age.info(.)) %>%
  group_by(age_group, facet_labels) %>%
  summarise(mp = mean(mean_post_loss_prob,na.rm=T),
            sp = sem(mean_post_loss_prob)) %>%
  ggplot(aes(facet_labels, mp, fill=age_group))+
  geom_bar(stat="identity",position=position_dodge())+
  geom_errorbar(width=0, aes(ymin = mp-sp, ymax = mp+sp), position = position_dodge(width=0.9))+
  xlab("")+
  ylab("Post loss play probability")+
  theme(legend.title = element_blank())

Response time differences

machine_game_data_clean %>%
  ggplot(aes(log(Reaction_time))) +
  geom_density(aes(fill = age_group), alpha=0.5, color=NA) +
  facet_wrap(~facet_labels)+
  theme(legend.title = element_blank())+
  ylab("")+
  xlab("Log Response Time")

machine_game_data_clean %>%
  group_by(Sub_id, facet_labels) %>%
  summarise(mean_log_rt = mean(log(Reaction_time)),
            sem_log_rt = sem(log(Reaction_time))) %>%
  do(assign.age.info(.)) %>%
  ggplot(aes(age_group, mean_log_rt))+
  geom_boxplot(aes(fill=age_group))+
  facet_wrap(~facet_labels)+
  theme(legend.position = "none")+
  ylab("Mean Log Rt")+
  xlab("Age group")

Both teens and adults are faster than kids in all conditions but the high var negative EV.

#summary(lmer(log(Reaction_time) ~ age_group*facet_labels +(1|Sub_id), data = machine_game_data_clean))

summary(lmer(log(Reaction_time) ~ age_group +(1|Sub_id), data = machine_game_data_clean%>%filter(facet_labels == "-10,+100")))

Linear mixed model fit by REML ['lmerMod']
Formula: log(Reaction_time) ~ age_group + (1 | Sub_id)
   Data: machine_game_data_clean %>% filter(facet_labels == "-10,+100")

REML criterion at convergence: 3528.4

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-3.5400 -0.6540 -0.1091  0.5703  3.8968 

Random effects:
 Groups   Name        Variance Std.Dev.
 Sub_id   (Intercept) 0.03464  0.1861  
 Residual             0.15763  0.3970  
Number of obs: 3371, groups:  Sub_id, 75

Fixed effects:
               Estimate Std. Error t value
(Intercept)     6.99491    0.03627 192.868
age_groupteen  -0.20684    0.05966  -3.467
age_groupadult -0.21703    0.05129  -4.231

Correlation of Fixed Effects:
            (Intr) ag_grpt
age_grouptn -0.608        
age_gropdlt -0.707  0.430 

summary(lmer(log(Reaction_time) ~ age_group +(1|Sub_id), data = machine_game_data_clean%>%filter(facet_labels == "-5,+495")))

Linear mixed model fit by REML ['lmerMod']
Formula: log(Reaction_time) ~ age_group + (1 | Sub_id)
   Data: machine_game_data_clean %>% filter(facet_labels == "-5,+495")

REML criterion at convergence: 4061.8

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-6.5760 -0.6509 -0.1139  0.6302  3.1327 

Random effects:
 Groups   Name        Variance Std.Dev.
 Sub_id   (Intercept) 0.04803  0.2192  
 Residual             0.18413  0.4291  
Number of obs: 3370, groups:  Sub_id, 75

Fixed effects:
               Estimate Std. Error t value
(Intercept)     6.99842    0.04239 165.082
age_groupteen  -0.14905    0.06974  -2.137
age_groupadult -0.11796    0.05996  -1.967

Correlation of Fixed Effects:
            (Intr) ag_grpt
age_grouptn -0.608        
age_gropdlt -0.707  0.430 

summary(lmer(log(Reaction_time) ~ age_group +(1|Sub_id), data = machine_game_data_clean%>%filter(facet_labels == "+10,-100")))

Linear mixed model fit by REML ['lmerMod']
Formula: log(Reaction_time) ~ age_group + (1 | Sub_id)
   Data: machine_game_data_clean %>% filter(facet_labels == "+10,-100")

REML criterion at convergence: 3801.4

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-3.2648 -0.6823 -0.1028  0.6509  3.1213 

Random effects:
 Groups   Name        Variance Std.Dev.
 Sub_id   (Intercept) 0.02927  0.1711  
 Residual             0.17155  0.4142  
Number of obs: 3375, groups:  Sub_id, 75

Fixed effects:
               Estimate Std. Error t value
(Intercept)     7.03189    0.03377 208.207
age_groupteen  -0.12876    0.05556  -2.318
age_groupadult -0.12068    0.04776  -2.527

Correlation of Fixed Effects:
            (Intr) ag_grpt
age_grouptn -0.608        
age_gropdlt -0.707  0.430 

summary(lmer(log(Reaction_time) ~ age_group +(1|Sub_id), data = machine_game_data_clean%>%filter(facet_labels == "+5,-495")))

Linear mixed model fit by REML ['lmerMod']
Formula: log(Reaction_time) ~ age_group + (1 | Sub_id)
   Data: machine_game_data_clean %>% filter(facet_labels == "+5,-495")

REML criterion at convergence: 3872.8

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-6.0286 -0.6820 -0.0941  0.6227  3.9061 

Random effects:
 Groups   Name        Variance Std.Dev.
 Sub_id   (Intercept) 0.03565  0.1888  
 Residual             0.17409  0.4172  
Number of obs: 3384, groups:  Sub_id, 75

Fixed effects:
               Estimate Std. Error t value
(Intercept)     6.98863    0.03691 189.320
age_groupteen  -0.08277    0.06072  -1.363
age_groupadult -0.08177    0.05220  -1.567

Correlation of Fixed Effects:
            (Intr) ag_grpt
age_grouptn -0.608        
age_gropdlt -0.707  0.430 

RL modeling

Details of model comparison can be found in a separate notebook.

Based on a comparison of 6 models the best fitting model is a 4 parameter model with one learning rate (\(\alpha\)) and two exponents (\(\gamma\)) weighing positive and negative prediction errors separately (along with the inverse softmax temperature \(\beta\) ).

In line with the above analyses where the behavioral difference lay in the high variance negative EV machine the age difference in the parameters is found in:

1. exponent over negative prediction errors: Adults distort negative outcomes less. A negative outcome doesn’t feel as bad as it is for kids

2. inverse softmax temperature: Adults make decisions based more on EV compared to kids

Therefore the trial level PEs from this model will be used as a parametric regressor for the imaging analyses.